Usenet 1993 July

home *** CD-ROM | disk | FTP | other *** search

/ Usenet 1993 July / InfoMagic USENET CD-ROM July 1993.ISO / sources / misc / volume12 / ffccc / part09 < prev next >

Wrap

Text File | 1990-05-14 | 47.2 KB | 1,348 lines

Newsgroups: comp.sources.misc organization: CERN, Geneva, Switzerland keywords: fortran subject: v12i095: Floppy - Fortran Coding Convention Checker Part 09/11 from: julian@cernvax.cern.ch (julian bunn) Sender: allbery@uunet.UU.NET (Brandon S. Allbery - comp.sources.misc) Posting-number: Volume 12, Issue 95 Submitted-by: julian@cernvax.cern.ch (julian bunn) Archive-name: ffccc/part09 #!/bin/sh echo 'Start of Floppy, part 09 of 11:' echo 'x - CHKCHR.f' sed 's/^X//' > CHKCHR.f << '/' X SUBROUTINE CHKCHR XC Checks that incorrect relational operators XC are not used to compare XC character strings in IF clauses. XC INPUT ; current statement description XC OUTPUT ; NFAULT XC X include 'PARAM.h' X include 'ALCAZA.h' X include 'CLASS.h' X include 'FLAGS.h' X include 'CURSTA.h' X include 'STATE.h' X include 'USSTMT.h' X include 'USUNIT.h' X include 'USLTYD.h' X include 'USIGNO.h' X include 'CHECKS.h' X LOGICAL BTEST X IF(UNFLP) RETURN X IF(.NOT.LCHECK(42)) RETURN X ICL1 = ICURCL(1) X IF(.NOT.LIFF(ICL1)) RETURN XC Find end of IF X ILOC = INDEX(SSTA(:NCHST),'(') X IF(ILOC.EQ.0) RETURN X CALL SKIPLV(SSTA,ILOC+1,NCHST,.FALSE.,ILOCE,ILEV) X IF(ILOCE.EQ.0) RETURN X DO 40 I=1,NSNAME XC Looping over variable names in the statement X IF(NSSTRT(I).GT.ILOCE) RETURN XC Variable is inside IF clause X IF(.NOT.BTEST(NAMTYP(ISNAME+I),5)) GOTO 40 XC Character variable X DO 10 IPOS=NSSTRT(I)-1,ILOC+1,-1 X IF(SSTA(IPOS:IPOS).EQ.' ') GOTO 10 X IF(SSTA(IPOS:IPOS).EQ.'(') GOTO 20 X IF(SSTA(IPOS:IPOS).NE.'.') GOTO 20 XC Check for incorrect relational operators X IF(SSTA(IPOS-3:IPOS).EQ.'.OR.') GOTO 20 X IF(SSTA(IPOS-3:IPOS).EQ.'.EQ.') GOTO 20 X IF(SSTA(IPOS-3:IPOS).EQ.'.NE.') GOTO 20 X IF(SSTA(IPOS-4:IPOS).EQ.'.AND.') GOTO 20 X IF(ILOCE-ILOC.GT.20) ILOCE=ILOC+20 X WRITE(MZUNIT,500) SSTA(ILOC:ILOCE) X NFAULT = NFAULT + 1 X RETURN X 10 CONTINUE X 20 ILEV = 0 X DO 30 IPOS=NSEND(I)+1,ILOCE-1 X IF(SSTA(IPOS:IPOS).EQ.' ') GOTO 30 X IF(SSTA(IPOS:IPOS).EQ.'(') ILEV=ILEV+1 X IF(SSTA(IPOS:IPOS).EQ.')') ILEV=ILEV-1 X IF(SSTA(IPOS:IPOS).EQ.')') GOTO 30 X IF(ILEV.NE.0) GOTO 30 X IF(SSTA(IPOS:IPOS).NE.'.') GOTO 40 X IF(SSTA(IPOS:IPOS+3).EQ.'.OR.') GOTO 40 X IF(SSTA(IPOS:IPOS+3).EQ.'.EQ.') GOTO 40 X IF(SSTA(IPOS:IPOS+3).EQ.'.NE.') GOTO 40 X IF(SSTA(IPOS:IPOS+4).EQ.'.AND.') GOTO 40 X IF(ILOCE-ILOC.GT.20) ILOCE=ILOC+20 X WRITE(MZUNIT,500) SSTA(ILOC:ILOCE) X NFAULT = NFAULT + 1 X RETURN X 30 CONTINUE X 40 CONTINUE X RETURN X 500 FORMAT(1X,'!!! WARNING ... IF CLAUSE ',A,' USES', X +' INCORRECT RELATIONAL OPERATORS FOR CHARACTER TYPE') X END / echo 'x - CSTATE.h' sed 's/^X//' > CSTATE.h << '/' X*IF DEF,NEVER X*----------------------------------------------------------------------- X* /STATE/ contains the information concerning the actual X* status of the program X* NLINES no. of lines in line image buffer SIMA X* NKEEPL buffered line number in READEC, or 0 X* NSTAMM total no. of statements in current routine X* NFSTAT no. of FORTRAN statements in current routine X* ISNAME pointer to start-1 of stmt. names in SNAMES X* NSNAME no. of names found in statement X* IRNAME pointer to start-1 of names/routine in SNAMES X* NRNAME no. of names/routine X* IGNAME pointer to start-1 of global names in SNAMES X* NGNAME no. of global names X* INDCNT current indentation level (reset at routine start) X* INDFAC no. of ch./level to indent X* KNTDO current DO loop level (for indentation) X* KNTIF current IF...THEN level (for indentation) X* IBLPAD in QUOTES option, string blank-padded to multiples X* of IBLPAD (default = 1) X* NRORST no. of currently selected OR-sets in LRORST X* NSTANU no. of statement numbers in KSTANU, KSTARE X* ICBPRT no. of c.b. variables printed at ACTION(24) X* NCBNAM no. of c.b. names in NCBGRP, KCBGRP, SCBNAM X* NEQNAM no. of equiv. groups in NEQGRP, KEQGRP X* NCBVAR no. of names in SEQNAM X* NCBGRP no. of common block variables per c.b. X* KCBGRP pos.-1 of start of c.b. name list in SCBNAM X* LCBNAM # of c.b. variables used in current routine X* LCBVAR counts number of times a variable is referenced X* NEQGRP no. of names in equiv. group X* KEQGRP pos.-1 of start of equiv. group in SCBNAM X* LRORST list of OR-sets valid for current routine X* NAMTYP variable type, parallel to SNAMES X* NSSTRT start of name I in SSTA X* NSEND end of name I in SSTA X* KSTANU statement numbers in routine (sorted) X* KSTARE new statement numbers, corresponding to KSTANU X* NLTYPE type of line I (0 comment, 1 start, 2 cont. of stmt. ) X* ICLASS(I,1) type of statement I X* 0 = comment X* 999 = no comment, not classified X* class = ICURCL(1), common /CURSTA/ X* ICLASS(I,2) type of second part of statement I if logical IF X* IMODIF 10*n2 + n1 X* n1 = 1 : statement has been filtered X* n2 = 1 : statement has been modified X* NFLINE start of statement I in SIMA X* NLLINE end of statement I in SIMA X*----------------------------------------------------------------------- X*EI / echo 'x - FLAGS.h' sed 's/^X//' > FLAGS.h << '/' X COMMON/FLAGS/ACTION(MXFLAG),STATUS(MXFLAG) X LOGICAL ACTION,STATUS X*IF DEF,NEVER X*----------------------------------------------------------------------- X* +++++++++++++++++++++++++ action flags - as listed X* 1 make namelist/routine X* 2 make global namelist X* 3 print illegal statements X* 4 print changed statements X* 5 print filtered statements X* 6 print all statements X* 7 write changed statements only on output file X* 8 write filtered on output file X* 9 write all on output file X* 10 take first name only in statement X* 11 convert hollerith to quotes X* 12 string replacement requested X* 13 resequence statement numbers X* 14 FORMAT to end of routine X* 15 name replacements requested X* 16 routine filters given X* 17 class filters given X* 18 name filters given X* 19 string filters given X* 20 type variables X* 21 indent X* 22 USER command given X* 23 compressed output file requested X* 24 COMMON block option (signal unused and used C.B.) X* 25 print namelist / routine X* 26 print global namelist X* 27 print COMMON block and variable usage X* 28 adjust GOTO to the right X* 29 write tree output file on unit 13 X* +++++++++++++++++++++++++ status flags - as listed X* 1 no more lines on input X* 2 no more lines to process X* 3 illegal stmnt. detected in EXTRAC (unclosed string, or X* illegal character '{', '}' ). X* 4 end of program due to time limit X* 5 currently buffered routine without end (split) X* 6 currently buffered routine continuation (split) X* 7 current routine filtered X* 8 last filter passed X* 9 routine header still to be printed X* 10 statement still to be printed X* 11 statement cannot be changed (length overflow,or illegal repl.) X* 12 c.b. name list overflow in PROCOM, discard current routine X* 13 true when equiv. groups and commons have been merged (PROCOM) X* 14 true when current routine is a SUBROUTINE X*----------------------------------------------------------------------- X*EI / echo 'x - GETCON.f' sed 's/^X//' > GETCON.f << '/' X SUBROUTINE GETCON(STRING,I1,I2,KLCH,STYP) X*----------------------------------------------------------------------- X* X*--- returns a numeric constant, and its type. Constant must start on I1 X*--- input X* STRING(I1:I2) string X*--- output X* KLCH last pos. of const., or 0 if none X* STYP type of constant: X* 'I' = integer X* 'R' = real X* 'D' = double prec. X* 'K' = complex X* '$' = not specified X* X*----------------------------------------------------------------------- X CHARACTER *(*) STRING X CHARACTER*1 STYP,STEMP,SLAST,SLOG*7 X include 'CONVEX.h' X STYP='$' X KLCH=0 X STEMP=STRING(I1:I1) X IF(STEMP.EQ.'{') THEN X*--- string, hollerith, etc., all treated as CHARACTER X KPOS=INDEX(STRING(I1:I2),'}') X IF(KPOS.NE.0) THEN X KLCH=I1+KPOS-1 X STYP='C' X ENDIF X ELSEIF(STEMP.EQ.'.') THEN X*--- logical constant ? X CALL GETNBL(STRING(I1:I2),SLOG,NN) X IF(NN.GE.5) THEN X IF(SLOG(:5).EQ.'.NOT.'.OR.SLOG(:6).EQ.'.TRUE.' X + .OR.SLOG.EQ.'.FALSE.') THEN X CALL POSCH('.',STRING,I1+1,I2,.FALSE.,0,KLCH,ILEV) X IF(KLCH.NE.0) THEN X STYP='L' X GOTO 999 X ENDIF X ENDIF X ENDIF X ENDIF X IF(NUMCH(STEMP).OR.STEMP.EQ.'.') THEN X*--- integer, real, or double precision X KLCH=I1 X IF(STEMP.EQ.'.') THEN X STYP='R' X ELSE X STYP='I' X ENDIF X SLAST=STEMP X DO 10 I=I1+1,I2 X STEMP=STRING(I:I) X IF(STEMP.EQ.' ') GOTO 10 X IF(.NOT.NUMCH(STEMP)) THEN X IF(STEMP.EQ.'.'.OR.STEMP.EQ.'E') THEN X STYP='R' X ELSEIF(STEMP.EQ.'D') THEN X STYP='D' X ELSEIF((STEMP.EQ.'+'.OR.STEMP.EQ.'-').AND. (SLAST.EQ.'E' X + .OR.SLAST.EQ.'D')) THEN X CONTINUE X ELSE X GOTO 20 X ENDIF X ENDIF X KLCH=I X SLAST=STEMP X 10 CONTINUE X 20 CONTINUE X ELSEIF(STEMP.EQ.'(') THEN X*--- complex X CALL SKIPLV(STRING,I1+1,I2,.FALSE.,KLCH,ILEV) X IF(KLCH.GT.0) THEN X CALL POSCH(',',STRING,I1+1,KLCH-1,.FALSE.,0,KPOS,ILEV) X IF(KPOS.NE.0) STYP='K' X ENDIF X ENDIF X 999 END / echo 'x - INDECZ.f' sed 's/^X//' > INDECZ.f << '/' X SUBROUTINE INDECZ(ISTR1,ISTR2) X*----------------------------------------------------------------------- X* X* Checks consistency between replacement strings, kills illegal ones X* X*--- Input X* ISTR1 ref. to string to be replaced (rel. to KKYSTA, KKYEND) X* ISTR2 ref. to replacing string X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'ALCAZA.h' X include 'KEYCOM.h' X include 'FLWORK.h' X include 'CONDEC.h' X DIMENSION ICT1(10),ICT2(10),IREF1(MXNAME/20,10), IREF2(MXNAME/20, X +10) X EQUIVALENCE (IREF1(1,1),IWS(1)),(IREF2(1,1),IWS(MXNAME/2+1)) X CHARACTER *40 STEXT(4) X DATA STEXT/'too many special symbols', 'unclosed [...] in string', X +'replacement count [n] too high', X +'unclosed quote string inside string'/ X X include 'CONDAT.h' X IF(ISTR1.GT.0.AND.ISTR2.GT.0) THEN X*--- extract special symbols from first string X CALL SPECCT(1,ISTR1,NTOT1,ICT1,IREF1,IERR) X IF (IERR.NE.0) GOTO 30 X*--- second string X CALL SPECCT(2,ISTR2,NTOT2,ICT2,IREF2,IERR) X IF (IERR.NE.0) GOTO 30 X IF (NTOT2.GT.0) THEN X*--- there are special symbols in the replacement string - X* check that no count in [...] higher than actually present X DO 20 I=1,LEN(SPCHAR) X DO 10 J=1,ICT2(I) X IF (ICT1(I).LT.IREF2(J,I)) THEN X IERR=3 X GOTO 30 X ENDIF X 10 CONTINUE X 20 CONTINUE X ENDIF X ENDIF X GOTO 999 X 30 CONTINUE X*--- error condition - suppress string (or name+string) replacement X WRITE (MPUNIT,10000) STEXT(IERR) X I1=KKYSTA(ISTR1)-1 X I2=KKYEND(ISTR1) X L=(I2-I1-1)/MXLINE+1 X DO 40 I=1,L X SIMA(I)=SKYSTR(I1+1:MIN(I2,I1+MXLINE)) X I1=I1+MXLINE X 40 CONTINUE X CALL FLPRNT(0,'replace',L,SIMA,I1) X I1=KKYSTA(ISTR2)-1 X I2=KKYEND(ISTR2) X L=(I2-I1-1)/MXLINE+1 X DO 50 I=1,L X SIMA(I)=SKYSTR(I1+1:MIN(I2,I1+MXLINE)) X I1=I1+MXLINE X 50 CONTINUE X CALL FLPRNT(0,'by string',L,SIMA,I1) X ISTR1=-IERR X10000 FORMAT(/' +++++++ WARNING - ',A,' in following replacement ', X +'request, request ignored') X 999 END / echo 'x - PARAM.h' sed 's/^X//' > PARAM.h << '/' X PARAMETER(MXNAME=20000,MXSSTM=600,MXSTAT=71,MCLASS=22,MXLENG=1320, X 1 MXLINE=80,MXSIMA=2000,MXSIMD=MXSIMA+500,MCUNIT=7,MPUNIT=6, X 2 MIUNIT=11,MTUNIT=13,MOUNIT=14,MXFLAG=30,MXNMCH=8,MXORST=20, X 3 MDIMST=2000,MGLOKY=9,MLOCKY=4,MSUBKY=24,MTOTKY=MGLOKY+MLOCKY, X 4 MXKEYS=MGLOKY+MXORST*MLOCKY,MXKINT=100,MXKNAM=500,MXTYPE=20, X 5 MAXNUM=1000,MAXGRP=100,TIMLIM=1., X + VERSIO=6.00, X 6 KALL=100,KENT=20,NOARG=50) X*IF DEF,NEVER X*----------------------------------------------------------------------- X*--- MXNAME = dimension of IWS, COMMON/FLWORK/, and of SNAMES /ALCAZA/ X* MXSSTM = length of string SSTM, COMMON/ALCAZA/ X* MXSTAT = max. no. of statement definitions X* MCLASS = first dim. of ISTMDS( , ) = no. of control words/statement X* MXLENG = max. length of statement field (20*66) X* MXLINE = line length of input image X* MXSIMA = max. no. of lines in input image (one routine) X* MXSIMD = dim. of SIMA (excess for replacement overflows) X* MCUNIT = file for command input (data cards) X* MPUNIT = file for printed output X* MIUNIT = FORTRAN code input unit X* MTUNIT = TREE output unit X* MOUNIT = FORTRAN code output unit X* MXFLAG = no. of status and action flags X* MXNMCH = max. no. of characters per name X* MXORST = max. no. of OR-sets in control commands X* MDIMST = dimension of SSTA, SSTR, SKYSTR X* MGLOKY = no. of global command keys X* MLOCKY = no. of local (in each OR-set) command keys X* MSUBKY = no. of command sub-keys X* MXKINT = dim. of KEYINT /KEYINP/ X* MXKNAM = max. no. of names or strings on input commands (total) X* MXTYPE = max. no. of variable types X* MAXNUM = max. no. of statement numbers per routine X* MAXGRP = max. no. of c.b. names or equiv. groups (for ACTION(24)) X* TIMLIM = if less time left, refrain from reading next routine X* VERSIO = program version X* KALL = max. no. of different externals / routine (TREE) X* KENT = max. no. of ENTRY statements / routine (TREE) X* NOARG = max. no. of arguments / call (TREE) X*----------------------------------------------------------------------- X*EI / echo 'x - PRNAMF.f' sed 's/^X//' > PRNAMF.f << '/' X SUBROUTINE PRNAMF(ICC1,ICC2) X*----------------------------------------------------------------------- X* X* Prints name table with all attributes (types) X* X* Input X* ICC1 first name is SNAMES to be printed X* ICC2 last - - X* X* NAMTYP , common /STATE/ X* X* Each type corresponds to a bit position (for testing use ITBIT). X* X* Types are: X* X* Bit meaning X* X* 1 INTEGER X* 2 REAL X* 3 LOGICAL X* 4 COMPLEX X* 5 DOUBLE PRECISION X* 6 CHARACTER X* 7 PARAMETER X* 8 COMMON block name X* 9 NAMELIST name X* 10 statement function X* 11 INTRINSIC X* 12 EXTERNAL X* 13 PROGRAM name X* 14 BLOCK DATA name X* 15 SUBROUTINE X* 16 ENTRY X* 17 FUNCTION (intrinsic or external) X* 18 dimensioned X* 19 (routine or function) argument X* 20 in a COMMON block X* 21 strongly typed function (internal usage) X* X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'ALCAZA.h' X include 'STATE.h' X CHARACTER SLINE*120, STYP(MXTYPE)*18 X DIMENSION LTYP(MXTYPE) X DATA STYP/'INTEGER','REAL','LOGICAL','COMPLEX','DOUBLE PRECISION', X +'CHARACTER','PARAMETER','COMMON block','NAMELIST', X +'statement function','INTRINSIC','EXTERNAL','PROGRAM', X +'BLOCK DATA','SUBROUTINE','ENTRY','FUNCTION', 'array','argument', X +'in COMMON'/ X DATA LTYP/7,4,7,7,16,9,9,12,8,18,9,8,7,10,10,5,8,5,8,9/ X IP=0 X SLINE=' ' X DO 20 I=ICC1,ICC2 X SLINE(IP+1:IP+MXNMCH)=SNAMES(I) X IPT=IP+MXNMCH+3 X NT=NAMTYP(I) X DO 10 J=1,MXTYPE X IF (MOD(NT,2).NE.0) THEN X L=LTYP(J) X IF (IPT+L.LE.IP+60) THEN X SLINE(IPT+1:IPT+L)=STYP(J)(:L) X IPT=IPT+L+2 X ENDIF X ENDIF X NT=NT/2 X 10 CONTINUE X IF (IP.EQ.0) THEN X IP=60 X ELSE X IP=0 X WRITE (MPUNIT,'(1X,A120)') SLINE X SLINE=' ' X ENDIF X 20 CONTINUE X IF(IP.NE.0) THEN X WRITE (MPUNIT,'(1X,A120)') SLINE X ENDIF X END / echo 'x - PRTCOM.f' sed 's/^X//' > PRTCOM.f << '/' X SUBROUTINE PRTCOM X*----------------------------------------------------------------------- X* X* Prints common block usage and variables referenced X* as prepared by routine PROCOM (option COMMON). X* X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'ALCAZA.h' X include 'STATE.h' X CHARACTER*(MXNMCH) SLOC(5) X DIMENSION ILOC(5) X IF(NCBNAM.GT.0) THEN X NUSE=0 X DO 10 I=1,NCBNAM X IF(LCBNAM(I).GT.0) NUSE=NUSE+1 X 10 CONTINUE X WRITE(MPUNIT,10000) SCROUT,NCBNAM,NUSE X WRITE(MPUNIT,10010) (SCBNAM(I),LCBNAM(I),I=1,NCBNAM) X IF(ICBPRT.GT.0) THEN X WRITE(MPUNIT,10020) ICBPRT X DO 40 I=1,NCBNAM X N=0 X NT=0 X K=KCBGRP(I) X DO 20 J=1,NCBGRP(I) X IF(LCBVAR(K+J).NE.0) THEN X N=N+1 X NT=NT+1 X SLOC(N)=SCBVAR(K+J) X ILOC(N)=LCBVAR(K+J) X IF(NT.EQ.ICBPRT) GOTO 30 X IF(N.EQ.5) THEN X IF(NT.LE.5) THEN X WRITE(MPUNIT,10030) SCBNAM(I),(SLOC(M),ILOC X + (M),M=1,N) X ELSE X WRITE(MPUNIT,10040) (SLOC(M),ILOC(M),M=1,N) X ENDIF X N=0 X ENDIF X ENDIF X 20 CONTINUE X 30 CONTINUE X IF(N.GT.0) THEN X IF(NT.LE.5) THEN X WRITE(MPUNIT,10030) SCBNAM(I),(SLOC(M),ILOC(M),M=1, X + N) X ELSE X WRITE(MPUNIT,10040) (SLOC(M),ILOC(M),M=1,N) X ENDIF X ENDIF X 40 CONTINUE X ENDIF X ENDIF X10000 FORMAT(/' +++ routine ',A8,' has ',I5,' common blocks ', X +'of which ',I5,' are used') X10010 FORMAT(' c.b. name + no. of var. used ',T45, A8,I4,3X,A8,I4, 3 X +X,A8,I4,3X,A8,I4,3X,A8,I4/ (T45,A8,I4,3X,A8,I4,3X,A8,I4,3X,A8,I4,3 X +X,A8,I4)) X10020 FORMAT(/' list of first ',I5,' common variables in each ', X +'block + number of references'/) X10030 FORMAT(' /',A8,'/',T20,5(A8,I4,3X)) X10040 FORMAT(T20,5(A8,I4,3X)) X END / echo 'x - PUTOPT.f' sed 's/^X//' > PUTOPT.f << '/' X SUBROUTINE PUTOPT(SOPT,LOPT,ICHR,IERR) XC! Put an operator on the stack X include 'STACK.h' X CHARACTER*(*) SOPT X include 'OPPREC.h' XC XC Here we use the operator precedence for Fortran to determine XC whether the addition of this operator will cause the stack XC to be reduced. Note both right and left precedence is needed. XC Thanks to Julian Blake for this info. XC X IERR = 0 X DO 10 I=1,LOPS X IF(ILENO(I).NE.LOPT) GOTO 10 X IF(SOPT(:LOPT).EQ.COPER(I)(:LOPT)) GOTO 20 X 10 CONTINUE X IERR = 1 XC not found ... not an operator X GOTO 30 X 20 CONTINUE XC found. Operator number I X IOP = I X IPREC = IRITP(IOP) XC XC WRITE(6,100) NLEVL,(CTYP(I),COPD(I)(:LOPD(I)),COPT(I), XC & IPOP(I),IPOS(I), XC & I=NLEVL,1,-1) XC XC WRITE(6,110) SOPT(:LOPT),IPREC XC XC check if operator already present X IF(COPT(NLEVL)(:1).NE.' ') THEN X NLEVL = NLEVL + 1 X CTYP(NLEVL) = '$' X COPD(NLEVL)(:LCOPD) = ' ' X LOPD(NLEVL) = 0 X COPT(NLEVL)(:LOPER) = ' ' X COPT(NLEVL)(:LOPT) = SOPT(:LOPT) X IPOP(NLEVL) = ILEFP(IOP) X IPOS(NLEVL) = ICHR X IERR = 0 X GOTO 30 X ENDIF XC place operator on stack X COPT(NLEVL)(:LOPER) = ' ' X COPT(NLEVL)(:LOPT) = SOPT(:LOPT) X IPOP(NLEVL) = ILEFP(IOP) X IPOS(NLEVL) = ICHR XC check for reduction of stack X IF(NLEVL.EQ.1) THEN X IERR = 0 X GOTO 30 X ENDIF X IF(IRITP(IOP).GT.IPOP(NLEVL-1)) THEN X IERR = 0 X GOTO 30 X ENDIF XC expression must be reduced X CALL REDEXP(IOP,IERR) X IERR = -IERR X 30 CONTINUE X RETURN X 500 FORMAT(///,1X,'IN PUTOPT ... STACK LEVEL = ',I2, /,1X, X +'TYPE,OPERAND',23X,',OPERATOR,PRECEDENCE,POSITION', /,1X, X +'---- -------',23('-'),' -------- ---------- --------', (/,1X,2X, X +A1,2X,A30,8X,A2,6X,I2,8X,I2)) X 510 FORMAT(1X,'CURRENT OPERATOR -> ',A,' PRECEDENCE = ',I2) X END / echo 'x - QUOSUB.f' sed 's/^X//' > QUOSUB.f << '/' X SUBROUTINE QUOSUB X*----------------------------------------------------------------------- X* X* Removes {} = string indicators, changes " or ...H to ' if ACTION(11) X* X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'ALCAZA.h' X include 'FLAGS.h' X include 'CURSTA.h' X include 'STATE.h' X include 'JOBSUM.h' X CHARACTER *1 STEMP X NMOD=IMODIF(NSTREF) X NCH=0 X IPT=0 X 10 CONTINUE X IF (IPT.EQ.NCHST) GOTO 30 X IN=INDEX(SSTA(IPT+1:NCHST),'{') X IF (IN.EQ.0) GOTO 30 X L=IN-1 X IN=IPT+IN X IF(L.GT.0) THEN X IF (NCH+L.GT.MXLENG) GOTO 40 X SSTR(NCH+1:NCH+L)=SSTA(IPT+1:IPT+L) X NCH=NCH+L X ENDIF X IPT=IN X IN=INDEX(SSTA(IPT+1:NCHST),'}') X L=IN-1 X IN=IPT+IN X STEMP=SSTA(IPT+1:IPT+1) X IF(STEMP.EQ.''''.OR..NOT.ACTION(11)) THEN X IF (NCH+L.GT.MXLENG) GOTO 40 X SSTR(NCH+1:NCH+L)=SSTA(IPT+1:IN-1) X NCH=NCH+L X ELSE X*--- replace " or ...H, double up single quotes X IF (NMOD.LT.10) NMOD=NMOD+10 X IF (STEMP.EQ.'"') THEN X I1=IPT+2 X I2=IN-2 X ELSE X*--- find H X I1=IPT+INDEX(SSTA(IPT+1:NCHST),'H')+1 X I2=IN-1 X ENDIF X NCH=NCH+1 X IF (NCH.GT.MXLENG) GOTO 40 X SSTR(NCH:NCH)='''' X DO 20 I=I1,I2 X NCH=NCH+1 X IF (NCH.GT.MXLENG) GOTO 40 X STEMP=SSTA(I:I) X SSTR(NCH:NCH)=STEMP X IF (STEMP.EQ.'''') THEN X NCH=NCH+1 X IF (NCH.GT.MXLENG) GOTO 40 X SSTR(NCH:NCH)=STEMP X ENDIF X 20 CONTINUE X IF (IBLPAD.GT.1) THEN X*--- blank pad string up to multiple of IBLPAD X KPAD=MOD(I2+1-I1,IBLPAD) X IF (KPAD.GT.0) THEN X I=IBLPAD-KPAD X IF (NCH+I.GT.MXLENG) GOTO 40 X SSTR(NCH+1:NCH+I)=' ' X NCH=NCH+I X ENDIF X ENDIF X NCH=NCH+1 X IF (NCH.GT.MXLENG) GOTO 40 X SSTR(NCH:NCH)='''' X ENDIF X IPT=IN X GOTO 10 X 30 CONTINUE X*--- transfer rest and swap if modified X IF (IPT.EQ.0) GOTO 999 X L=NCHST-IPT+1 X IF(L.GT.0) THEN X IF (NCH+L.GT.MXLENG) GOTO 40 X SSTR(NCH+1:NCH+L)=SSTA(IPT+1:NCHST) X NCH=NCH+L X ENDIF X IMODIF(NSTREF)=NMOD X SSTA(:NCH)=SSTR(:NCH) X NCHST=NCH X GOTO 999 X 40 CONTINUE X*--- error exit - statement too long X WRITE (MPUNIT,10000) X CALL FLPRNT(1,'OVERFLOW',NLLINE(NSTREF)-NFLINE(NSTREF)+1, SIMA X +(NFLINE(NSTREF)),NDUMMY) X NSTATC(6)=NSTATC(6)+1 X STATUS(11)=.TRUE. X10000 FORMAT(/' ++++++ Warning - replacements would lead to overflow', X +' in following statement, not done') X 999 END / echo 'x - REDEXP.f' sed 's/^X//' > REDEXP.f << '/' X SUBROUTINE REDEXP(IOP,IERR) XC! Reduce the expression on the stack X include 'PARAM.h' X include 'CURSTA.h' X include 'STACK.h' X include 'ALCAZA.h' X include 'USUNIT.h' X CHARACTER*(MDIMST) CTEMP X CHARACTER*(LCOPD) SNEW X CHARACTER*1 SNUTY X include 'OPPREC.h' XC XC WRITE(6,100) XC 100 FORMAT(//,1X,'Now reduce the expression on the stack') XC X IERR = 0 X 5 CONTINUE X IF(NLEVL.LE.1) THEN X IERR = 1 X GOTO 900 X ENDIF XC X L1 = MAX(1,LOPD(NLEVL-1)) X L2 = MAX(1,INDEX(COPT(NLEVL-1),' ' )-1) X L3 = MAX(1,LOPD(NLEVL)) X L = L1+L2+L3 XC The exepression to be reduced is SNEW X SNEW(:L)=COPD(NLEVL-1)(:L1)//COPT(NLEVL-1)(:L2)//COPD(NLEVL)(:L3) XC XC check for generic intrinsic function XC if so, then assign the type of the expression in parentheses XC to the function XC X IF(CTYP(NLEVL-1).EQ.'$'.AND.COPT(NLEVL-1)(:1).EQ.'(') THEN X CTYP(NLEVL-1) = CTYP(NLEVL) X ENDIF XC XC check for mixed mode operation XC X CALL OPRSLT(CTYP(NLEVL-1),COPT(NLEVL-1),CTYP(NLEVL), X & IERR,SNUTY) X IF(IERR.EQ.1) THEN X DO 10 ICH=1,NCHST X CTEMP(ICH:ICH) = ' ' X IF(ICH.EQ.IPOS(NLEVL-1)) CTEMP(ICH:ICH) = '^' X 10 CONTINUE XC WRITE(6,110) SSTA(1:NCHST),CTEMP(:NCHST) X IFINT=MIN(NCHST,100) X WRITE(MZUNIT,110) SSTA(1:IFINT),CTEMP(1:IFINT) X 110 FORMAT(1X,'!!! MIXED MODE EXPRESSION (BAD OPERATOR IS MARKED)', X & /,1X,A,/,1X,A) X GOTO 900 X ENDIF XC XC treat matching parantheses specially XC X IF(COPT(NLEVL-1).EQ.'('.AND.COPER(IOP).EQ.')') THEN X IF(L1.EQ.0) THEN X SNUTY = CTYP(NLEVL) X ELSE X SNUTY = CTYP(NLEVL-1) X ENDIF X SNEW(:L+1) = SNEW(:L)//')' X L = L+1 X NLEVL = NLEVL - 1 X CTYP(NLEVL) = SNUTY X COPD(NLEVL) = SNEW X LOPD(NLEVL) = L X COPT(NLEVL) = ' ' X IPOP(NLEVL) = 0 X IPOS(NLEVL) = 0 X GOTO 900 X ENDIF XC X NLEVL = NLEVL-1 X CTYP(NLEVL) = SNUTY X COPD(NLEVL) = SNEW X LOPD(NLEVL) = L X COPT(NLEVL) = COPER(IOP) X IPOP(NLEVL) = ILEFP(IOP) X IPOS(NLEVL) = 0 XC X IF(IRITP(IOP).GT.IPOP(NLEVL-1)) THEN X GOTO 900 X ENDIF XC XC continue reduction XC X GOTO 5 X 900 CONTINUE X RETURN X END / echo 'x - REPSTR.f' sed 's/^X//' > REPSTR.f << '/' X SUBROUTINE REPSTR X*----------------------------------------------------------------------- X* X* Performs string replacements X* X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'ALCAZA.h' X include 'FLAGS.h' X include 'CURSTA.h' X include 'STATE.h' X include 'KEYCOM.h' X include 'JOBSUM.h' X DIMENSION KSP1(100),KSP2(100) X CHARACTER*1 STEMP X NMOD=IMODIF(NSTREF) X*--- check for 'REP' key X DO 10 IK=1,NGLSET X IF (KEYREF(IK,1).EQ.9) GOTO 20 X 10 CONTINUE X GOTO 999 X 20 CONTINUE X*--- check for string replacement X IF (KEYREF(IK,6).EQ.0) GOTO 999 X DO 50 I=KEYREF(IK,7)+1,KEYREF(IK,7)+KEYREF(IK,6) X NCH=0 X IPT=0 X KREF1=KSTREF(I,1) X KREF2=KSTREF(I,2) X*--- check illegal X IF (KREF1.LE.0) GOTO 50 X K1=KKYSTA(KREF1) X K2=KKYEND(KREF1) X IF (SKYSTR(K1:K1).NE.'#') THEN X*--- insert '#' for free match X KST=1 X K1=K1-1 X STEMP=SKYSTR(K1:K1) X SKYSTR(K1:K1)='#' X ELSE X KST=0 X ENDIF X 30 CONTINUE X CALL MATCH(SKYSTR,K1,K2,SSTA,IPT+1,NCHST,.TRUE.,KPOS,ILEV,NSPEC X + ,KSP1,KSP2) X IF (KPOS.EQ.0) GOTO 40 X*--- string does match X*--- set modify flag X IF (NMOD.LT.10) NMOD=NMOD+10 X*--- transfer additional '#' if there X IF (KST.NE.0) THEN X L=KSP2(1)-IPT X IF (L.GT.0) THEN X SSTR(NCH+1:NCH+L)=SSTA(IPT+1:IPT+L) X NCH=NCH+L X ENDIF X ENDIF X IPT=KPOS X IF (KREF2.GT.0) THEN X*--- non-empty replacement string exists X CALL REPSUB(KREF1,KREF2,NSPEC-KST,KSP1(KST+1),KSP2(KST+1), X + NCH) X IF (NCH.GT.MXLENG) GOTO 60 X ENDIF X IF (IPT.LT.NCHST) GOTO 30 X 40 CONTINUE X IF (KST.NE.0) SKYSTR(K1:K1)=STEMP X IF (IPT.NE.0) THEN X*--- copy SSTR to SSTA, NCH to NCHST X L=NCHST-IPT X IF (L.GT.0) THEN X IF (NCH+L.GT.MXLENG) GOTO 60 X SSTR(NCH+1:NCH+L)=SSTA(IPT+1:NCHST) X NCH=NCH+L X ENDIF X NCHST=NCH X SSTA(:NCH)=SSTR(:NCH) X ENDIF X 50 CONTINUE X IMODIF(NSTREF)=NMOD X GOTO 999 X 60 CONTINUE X WRITE (MPUNIT,10000) X CALL FLPRNT(1,'OVERFLOW',NLLINE(NSTREF)-NFLINE(NSTREF)+1, SIMA X +(NFLINE(NSTREF)),NDUMMY) X NSTATC(6)=NSTATC(6)+1 X STATUS(11)=.TRUE. X10000 FORMAT(/' ++++++ Warning - replacements would lead to overflow', X +' in following statement, not done') X 999 END / echo 'x - SETIMP.f' sed 's/^X//' > SETIMP.f << '/' X SUBROUTINE SETIMP X*----------------------------------------------------------------------- X* X* Sets the default type list for an IMPLICIT statement, updates the X* already existing routine names (except for strongly typed). X* X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'ALCAZA.h' X include 'CONDEC.h' X include 'FLWORK.h' X include 'CURSTA.h' X include 'TYPDEF.h' X CHARACTER STYP(6)*16,STEMP*1,SPREV*1,STEMP2*2 X DIMENSION LTYP(6) X DATA STYP/'#INTEGER','#REAL','#LOGICAL','#COMPLEX', X +'#DOUBLEPRECISION','#CHARACTER'/ X DATA LTYP/8,5,8,8,16,10/ X include 'CONDAT.h' X IPT=0 X 10 CONTINUE X IND=NCHST X DO 20 I=1,6 X CALL MATCH(STYP(I),1,LTYP(I),SSTA,IPT+1,NCHST,.FALSE.,IPOS,ILEV X + ,NSPEC,IWS,IWS) X IF (IPOS.GT.0.AND.IPOS.LE.IND) THEN X IND=IPOS X IT=I X ENDIF X 20 CONTINUE X IF (IND+3.GT.NCHST) GOTO 999 X IPT=IND X*--- skip possible '*(...)' following the key X CALL GETNBL(SSTA(IPT+1:NCHST),STEMP2,NN) X IF (NN.LT.2) GOTO 999 X IF(STEMP2.EQ.'*(') THEN X IPT=IPT+INDEX(SSTA(IPT+1:NCHST),'(') X CALL SKIPLV(SSTA,IPT+1,NCHST,.FALSE.,IPOS,ILEV) X IF (IPOS.EQ.0) GOTO 999 X IPT=IPOS X ENDIF X*--- get start and end of bracket following type X IND=INDEX(SSTA(IPT+1:NCHST),'(') X IF (IND.EQ.0) GOTO 999 X IPT=IPT+IND X CALL SKIPLV(SSTA,IPT+1,NCHST,.FALSE.,IPOS,ILEV) X IF (IPOS.EQ.0) GOTO 999 X*--- loop over bracket, set type, reset types routine name table X SPREV=' ' X KP=27 X DO 40 I=IPT+1,IPOS-1 X STEMP=SSTA(I:I) X IF (STEMP.EQ.' ') GOTO 40 X K=ICVAL(STEMP) X IF (K.GT.0.AND.K.LE.26) THEN X IF (SPREV.EQ.'-') THEN X DO 30 J=KP,K X KVTYPE(J)=IT X 30 CONTINUE X ELSE X KVTYPE(K)=IT X ENDIF X KP=K X ENDIF X SPREV=STEMP X 40 CONTINUE X IPT=IPOS X GOTO 10 X 999 END / echo 'x - SKIPTP.f' sed 's/^X//' > SKIPTP.f << '/' X SUBROUTINE SKIPTP(ITYPE,STRING,ICC1,ICC2,HOLFLG,KPOS,ILEV) X*----------------------------------------------------------------------- X* positions on the last character of a string of the requested type X* input X* ITYPE 1 = numeric X* 2 = alpha X* 3 = alpha-numeric X* 4 = special X* 5 = FORTRAN-name X* 6 = expression ( no [,] at level 0 ) X* STRING string X* ICC1 first ch, in string X* ICC2 last - - - X* HOLFLG if TRUE, hollerith included X* output X* KPOS position of last ch. of given type, if ICC1 is of that X* type, otherwise = 0 X* ILEV level (including KPOS) relative to input level 0 X*----------------------------------------------------------------------- X LOGICAL HOLFLG X CHARACTER STRING*(*),STEMP*1 X include 'CONVEX.h' X ILEV=0 X KPOS=0 X NCNT=0 X ISSTR=0 X ILBASE=-1 X JC=ICC1-1 X 10 JC=JC+1 X IF (JC.GT.ICC2) GOTO 999 X STEMP=STRING(JC:JC) X*--- skip blanks outside strings X IF (STEMP.EQ.' '.AND.ISSTR.EQ.0) GOTO 10 X IF(STEMP.EQ.'{') THEN X*--- start of character string X ISSTR=1 X IF (.NOT.HOLFLG) THEN X ISSTR=0 X I=INDEX(STRING(JC:ICC2),'}') X IF (I.EQ.0) GOTO 999 X JC=I+JC-2 X ENDIF X GOTO 10 X ELSEIF(STEMP.EQ.'}') THEN X ISSTR=0 X IF(ITYPE.EQ.6) THEN X KPOS=JC X ELSE X GOTO 10 X ENDIF X ELSEIF(ITYPE.EQ.1) THEN X IF (NUMCH(STEMP)) KPOS=JC X ELSEIF(ITYPE.EQ.2) THEN X IF (ALPHCH(STEMP)) KPOS=JC X ELSEIF(ITYPE.EQ.3) THEN X IF (ANUMCH(STEMP)) KPOS=JC X ELSEIF(ITYPE.EQ.4) THEN X IF (SPECCH(STEMP)) THEN X KPOS=JC X IF (STEMP.EQ.'(') THEN X ILEV=ILEV+1 X ELSEIF (STEMP.EQ.')') THEN X ILEV=ILEV-1 X ENDIF X ENDIF X ELSEIF(ITYPE.EQ.5) THEN X IF (NCNT.EQ.0) THEN X IF (ALPHCH(STEMP)) THEN X KPOS=JC X NCNT=NCNT+1 X ENDIF X ELSEIF (ANUMCH(STEMP)) THEN X KPOS=JC X ENDIF X ELSEIF(ITYPE.EQ.6) THEN X IF (KPOS.EQ.0.AND..NOT.(ANUMCH(STEMP).OR.STEMP.EQ.'('.OR.STEMP. X + EQ.'+'.OR.STEMP.EQ.'-'.OR.STEMP.EQ.''''))GOTO 999 X IF (STEMP.EQ.'(') THEN X ILEV=ILEV+1 X ELSEIF (ILBASE.LT.0) THEN X ILBASE=ILEV X ENDIF X IF (STEMP.EQ.')') ILEV=ILEV-1 X IF ((STEMP.NE.','.OR.ILEV-ILBASE.GT.0).AND.ILEV.GE.0) KPOS=JC X ENDIF X IF (KPOS.EQ.JC) GOTO 10 X 999 END / echo 'x - SPECCT.f' sed 's/^X//' > SPECCT.f << '/' X SUBROUTINE SPECCT(MODE,ISTR,NTOT,ICT,IREF,IERR) X*----------------------------------------------------------------------- X* Extracts information on special characters from strings X* Input X* MODE = 1 : treat a string which is to be replaced X* = 2 : treat a replacement string X* ISTR = string ref. (relative to KKYSTA, KKYEND) X* Output X* NTOT = total no. of special characters X* ICT (I) = count for character I (in SPCHAR) X* IREF(J,I)= if MODE = 1 : X* for the Jth character I, total count X* if MODE = 2 : X* for the Jth character I, count in [...] X* X*--- important: special characters inside '...' not counted ! X* X* IERR = 0 : all OK X* = 1 : buffer overflow X* = 2 : unclosed [...] X* = 3 : number in [...] out of range X* = 4 : unclosed '...' inside string X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'KEYCOM.h' X DIMENSION ICT(*),IREF(MXNAME/20,*) X include 'CONVEX.h' X IERR=0 X NTOT=0 X INSTR=0 X DO 10 I=1,7 X ICT(I)=0 X 10 CONTINUE X J=KKYSTA(ISTR)-1 X KEND=KKYEND(ISTR) X 20 CONTINUE X J=J+1 X IF (J.GT.KEND) GOTO 30 X IF(SKYSTR(J:J).EQ.'''') INSTR=1-INSTR X IF (INSTR.NE.0) GOTO 20 X I=INDEX(SPCHAR,SKYSTR(J:J)) X IF(I.EQ.7) THEN X*--- '>' found, look for ')' to follow X IF (J.EQ.KEND) THEN X I=0 X ELSEIF (SKYSTR(J+1:J+1).EQ.')') THEN X J=J+1 X ELSE X I=0 X ENDIF X ENDIF X IF(I.GT.0) THEN X*--- check buffer size X IF (ICT(I).EQ.MXNAME/2) THEN X IERR=1 X GOTO 999 X ENDIF X NTOT=NTOT+1 X ICT(I)=ICT(I)+1 X IF (MODE.EQ.1) THEN X IREF(ICT(I),I)=NTOT X ELSEIF (J.LT.KEND.AND.SKYSTR(J+1:J+1).EQ.'[') THEN X J=J+1 X IF (J.EQ.KEND) THEN X IERR=2 X GOTO 999 X ELSEIF (SKYSTR(J+1:J+1).EQ.']') THEN X IREF(ICT(I),I)=ICT(I) X ELSE X*--- get integer in [...] X CALL GETINT(SKYSTR,J+1,KEND,KFCH,KLCH,NN) X IF (KFCH.EQ.0.OR.NN.EQ.0) THEN X IERR=3 X GOTO 999 X ELSE X IREF(ICT(I),I)=NN X IF (KLCH.EQ.KEND) THEN X IERR=2 X GOTO 999 X ENDIF X J=KLCH+1 X IF (SKYSTR(J:J).NE.']') THEN X IERR=2 X GOTO 999 X ENDIF X ENDIF X ENDIF X ELSE X IREF(ICT(I),I)=ICT(I) X ENDIF X ENDIF X GOTO 20 X 30 CONTINUE X IF(INSTR.NE.0) IERR=4 X 999 END / echo 'x - STSUMM.f' sed 's/^X//' > STSUMM.f << '/' X SUBROUTINE STSUMM X*----------------------------------------------------------------------- X* X*--- Prints statement count summary X* X*----------------------------------------------------------------------- X include 'PARAM.h' X include 'ALCAZA.h' X include 'FLWORK.h' X include 'JOBSUM.h' X include 'CLASS.h' X DIMENSION IREF(3,MXSTAT),IOUT(4,2) X EQUIVALENCE (IREF(1,1),IWS(1)) X DO 10 I=1,NCLASS X DO 10 J=1,3 X 10 IREF(J,I)=0 X*--- collect references to external classes X DO 20 I=1,NCLASS X K=ISTMDS(6,I) X IREF(1,K)=I X IREF(2,K)=IREF(2,K)+NFDCLS(I,1) X IREF(3,K)=IREF(3,K)+NFDCLS(I,2) X 20 CONTINUE X WRITE (MPUNIT,10000) X N=0 X DO 30 I=1,NCLASS X K=IREF(1,I) X IF (K.NE.0) THEN X N=N+1 X IOUT(1,N)=I X IOUT(2,N)=IREF(2,I) X IOUT(3,N)=IREF(3,I) X IOUT(4,N)=K X IF (N.EQ.2) THEN X N=0 X WRITE (MPUNIT,10010) IOUT(1,1),SNAM(ISTMDS(1,IOUT(4,1)): X + ISTMDS(2,IOUT(4,1))),IOUT(2,1),IOUT(3,1),IOUT(1,2),SNAM( X + ISTMDS(1,IOUT(4,2)):ISTMDS(2,IOUT(4,2))),IOUT(2,2),IOUT X + ( 3,2) X ENDIF X ENDIF X 30 CONTINUE X IF(N.GT.0) THEN X WRITE (MPUNIT,10010) IOUT(1,1),SNAM(ISTMDS(1,IOUT(4,1)):ISTMDS( X + 2,IOUT(4,1))),IOUT(2,1),IOUT(3,1) X ENDIF X10000 FORMAT('1',10('----'),' Summary for filtered statements ', 10( X +'----')// X +' Except for ILLEGAL (all occurrences in filtered routines),', X +' only filtered statements counted.'/ X +' There are two types of counts, 1 = overall occurence, ', X +'2 = behind logical IF'// ' number',15X,'name',T41, X +' count-1 count-2', T61,' number',15X,'name',T101, X +' count-1 count-2'/) X10010 FORMAT(1X,I6,4X,A29,2I8,T61,1X,I6,4X,A29,2I8) X END / echo 'x - USLTYP.f' sed 's/^X//' > USLTYP.f << '/' X LOGICAL FUNCTION LMODUL(I) X LMODUL = I.EQ.3.OR.I.EQ.9.OR.I.EQ.12.OR.I.EQ.21.OR.I.EQ. X & 26.OR.I.EQ.33.OR.I.EQ.41.OR.I.EQ.47.OR.I.EQ. X & 56.OR.I.EQ.60.OR.I.EQ.67 X END X LOGICAL FUNCTION LFUNCT(I) X LFUNCT = I.EQ.9.OR.I.EQ.12.OR.I.EQ.21.OR.I.EQ.33.OR.I.EQ.41. X & OR.I.EQ.47.OR.I.EQ.60 X END X LOGICAL FUNCTION LNSVT(I) X LNSVT = I.EQ.10.OR.I.EQ.42.OR.I.EQ.48.OR.I.EQ.61 X END X LOGICAL FUNCTION LCOMMN(I) X LCOMMN = I.EQ.8 X END X LOGICAL FUNCTION LDIMEN(I) X LDIMEN = I.EQ.10.OR.I.EQ.11.OR.I.EQ.13.OR.I.EQ.14.OR.I.EQ.17. X & OR.I.EQ.42.OR.I.EQ.43.OR.I.EQ.48.OR.I.EQ.49.OR.I.EQ. X & 61.OR.I.EQ.62.OR.I.EQ.22 X END X LOGICAL FUNCTION LELSE(I) X LELSE = I.EQ.30.OR.I.EQ.29 X END X LOGICAL FUNCTION LGOTO(I) X LGOTO = I.GE.34.AND.I.LE.36 X END X LOGICAL FUNCTION LPRINT(I) X LPRINT = I.EQ.53 X END X LOGICAL FUNCTION LIFF(I) X LIFF = I.GE.37.AND.I.LE.39.OR.I.EQ.30 X END X LOGICAL FUNCTION LWRITE(I) X LWRITE = I.EQ.68 X END X LOGICAL FUNCTION LPAUSE(I) X LPAUSE = I.EQ.55 X END X LOGICAL FUNCTION LSAVE(I) X LSAVE = I.EQ.65 X END X LOGICAL FUNCTION LSTOP(I) X LSTOP = I.EQ.66 X END X LOGICAL FUNCTION LENTRY(I) X LENTRY = I.EQ.26 X END X LOGICAL FUNCTION LIO(I) X LIO = I.EQ.4.OR.I.EQ.5.OR.I.EQ.15.OR.I.EQ.25.OR.I.EQ.52. X & OR.I.EQ.53.OR.I.EQ.57.OR.I.EQ.58.OR.I.EQ.59.OR.I. X & EQ.64.OR.I.EQ.68 X END X LOGICAL FUNCTION LRETRN(I) X LRETRN = I.EQ.63 X END X LOGICAL FUNCTION LMODUS(I) X LMODUS = I.EQ.3.OR.I.EQ.9.OR.I.EQ.12.OR.I.EQ.21. X & OR.I.EQ.33.OR.I.EQ.41.OR.I.EQ.47.OR.I.EQ.56.OR. X & I.EQ.60.OR.I.EQ.67 X END X LOGICAL FUNCTION LCHARC(I) X LCHARC = I.EQ.13.OR.I.EQ.14 X END X LOGICAL FUNCTION LDECLR(I) X LOGICAL LDIMEN X LDECLR = LDIMEN(I).OR.I.EQ.8.OR.I.EQ.27.OR.I.EQ.28.OR.I.EQ. X & 44.OR.I.EQ.46.OR.I.EQ.51.OR.I.EQ.54.OR.I.EQ.65 X END X LOGICAL FUNCTION LDATA(I) X LDATA = I.EQ.16 X END X LOGICAL FUNCTION LASIGN(I) X LASIGN = I.GE.69.AND.I.LE.71 X END / echo 'x - copyright' sed 's/^X//' > copyright << '/' X************************************************************************ X* * X* CERN * X* * X* EUROPEAN ORGANIZATION FOR PARTICLE PHYSICS * X* * X* Program name: FLOPPY : Fortran Coding Convention Checker * X* and source tidier * X* * X* Authors : J.J.Bunn and H. Grote * X* CERN * X* CH-1211 GENEVA 23 * X* SWITZERLAND * X* JULIAN at CERNVM.CERN.CH * X* VXCERN::JULIAN (DECNET) node 22.37 * X* * X* Copyright CERN, Geneva 1990 - Copyright and any other * X* appropriate legal protection of this computer program and * X* associated documentation reserved in all countries of the * X* world. * X* * X* CERN undertakes no obligation for the maintenance of this * X* program or package, nor responsibility for its correctness, * X* and accepts no liability whatsoever resulting from the use of * X* it. * X* * X* Programs and documentation are provided solely for the use of * X* the organization to which they are distributed. * X* The program may be obtained from CERN subject to CERN * X* distribution rules. * X* * X* This program may not be copied or otherwise distributed * X* without permission. This message must be retained on this and * X* any other authorized copies. * X* * X* The material cannot be sold. CERN should be given credit in * X* all references. * X* * X************************************************************************ / echo 'Part 09 of Floppy complete.' exit